open Ada_lexical;;

module type UTF8 = sig
	val sequence : ?invalid_sequence:exn -> char -> int;;
	val get_code : ?invalid_sequence:exn -> string -> int ref -> int;;
end;;

module type StreamType = sig
	type 'a t;;
	val next: 'a t -> 'a;;
	exception Failure;;
end;;

module Scanner (UTF8: UTF8) (Integer: NumericType) (Real: NumericType)
	(LexicalElement: LexicalElementType with type integer = Integer.t and type real = Real.t)
	(Input: StreamType) =
struct
	
	type text_file_position = string * int * int;;
	
	type t = {
		mutable filename: string;
		mutable line: int;
		mutable column: int;
		mutable tokens: (LexicalElement.t * text_file_position) Queue.t;
		mutable last: LexicalElement.t;
		mutable h: char;
		tab: int;
		source: char Input.t};;
	
	let create (tab: int) (filename: string) (s: char Input.t): t = (
		{filename = filename; line = 1; column = 0;
			tokens = Queue.create (); last = LexicalElement.Eof;
			h = ' '; tab = tab; source = s}
	);;
	
	module Private = struct
		
		let current_position it = (
			(it.filename, it.line, it.column)
		);;
		
		let take it: unit = (
			it.column <- it.column + 1;
			try it.h <- Input.next it.source 
			with Input.Failure -> it.h <- '\x1a'
		);;
		
		let skip_spaces it: unit = (
			while (
				if it.h = ' ' || it.h = '\x0b' then (
					take it;
					true
				) else if it.h = '\t' then (
					it.column <- it.column + it.tab - 1;
					it.column <- it.column - it.column mod it.tab;
					take it;
					true
				) else if it.h = '\r' then (
					it.line <- it.line + 1;
					take it;
					if it.h = '\n' then take it;
					it.column <- 1;
					true
				) else if it.h = '\n' || it.h = '\x0c' then (
					it.line <- it.line + 1;
					it.column <- 0;
					take it;
					true
				) else (
					false
				)
			) do
				()
			done
		);;
		
		let add_error it (message: string) (position: text_file_position): unit = (
			Queue.add (LexicalElement.Lexical_error message, position) it.tokens
		);;
		
		let add it (e: LexicalElement.t) (position: text_file_position): unit = (
			it.last <- e;
			Queue.add (e, position) it.tokens
		);;
		
		let add_integer it ~(error: bool) (base: int) (integer_part: string) (exponent: int) (position: text_file_position): unit = (
			let t = (
				if error then (
					LexicalElement.Invalid_literal
				) else (
					let v = Integer.of_basedstring ~base integer_part in
					let v = (if exponent = 0 then v else Integer.scaling ~base ~adjustment:exponent v) in
					LexicalElement.Integer_literal v
				)
			) in
			add it t position
		);;
		
		let add_real it ~(error: bool) (base: int) (integer_part: string) (decimal_part: string) (exponent: int) (position: text_file_position): unit = (
			let t = (
				if error then (
					LexicalElement.Invalid_literal
				) else (
					let v = Real.of_basedstring ~base (integer_part ^ "." ^ decimal_part) in
					let v = (if exponent = 0 then v else Real.scaling ~base ~adjustment:exponent v) in
					LexicalElement.Real_literal v
				)
			) in
			add it t position
		);;
		
		let read_digits it ~(base: int) ~(based: bool) ~(will_e: bool): bool * string = (
			let b = Buffer.create 16 in
			let e = ref None in
			let s = ref None in
			let z = ref None in
			while (
				begin match it.h with 
				| '0'..'9' when Char.code it.h - Char.code '0' < base ->
					Buffer.add_char b it.h; 
					s := None;
					true
				| 'A'..'F' when Char.code it.h - Char.code 'A' + 10 < base -> 
					Buffer.add_char b it.h; 
					s := None;
					true
				| 'a'..'f' when Char.code it.h - Char.code 'a' + 10 < base -> 
					Buffer.add_char b it.h; 
					s := None;
					true
				| '_' -> 
					let p = Some (current_position it) in
					if Buffer.length b = 0 then e := p;
					if !s = None then s := p;
					true 
				| 'E' | 'e' when will_e ->
					false
				| '0'..'9' | 'A'..'Z' | 'a'..'z' ->
					if !z = None then z := Some (current_position it);
					true
				| _ -> 
					false
				end
			) do
				take it
			done;
			begin match !z with
			| Some p ->
				if based then (
					add_error it "digits should be less than base." p
				) else (
					add_error it "bad character in numeric literal." p
				);
				true, Buffer.contents b
			| None ->
				begin match !e with
				| Some p ->
					add_error it "'_' placed wrong in digits." p;
					true, Buffer.contents b
				| None ->
					begin match !s with
					| Some p ->
						add_error it "'_' placed wrong in digits." p;
						true, Buffer.contents b
					| None ->
						false, Buffer.contents b
					end
				end
			end
		);;
		
		let scan_exponent_part it ~(error: bool) (base: int) (integer_part: string) (decimal_part: string) (is_real: bool) (p: text_file_position): unit = (
			assert (it.h = 'E' || it.h = 'e');
			take it;
			let error, e = (
				begin match it.h with 
				| '-' ->
					take it;
					if not is_real then (
						add_error it "exponent of integer should not be negative." (current_position it);
						true, -1
					) else (
						false, -1
					)
				| '+' ->
					take it;
					error, 1
				| _ ->
					error, 1
				end
			) in
			let error, exp = (
				begin match read_digits it ~base:10 ~based:false ~will_e:false with
				| true, _ ->
					true, 0
				| false, "" ->
					add_error it "exponent expected." (current_position it);
					true, 0
				| false, s ->
					if it.h = '.' then (
						add_error it "exponent should be integer." (current_position it);
						take it;
						let (_: bool * string) = read_digits it ~base:10 ~based:false ~will_e:false in
						true, 0
					) else (
						error, e * int_of_string s
					)
				end
			) in
			if is_real then (
				add_real it ~error base integer_part decimal_part exp p
			) else (
				add_integer it ~error base integer_part exp p
			)
		);;
		
		let scan_decimal_part it ~(error: bool) (base: int) (integer_part: string) (mark: char) (p: text_file_position): unit = (
			let error, decimal_part = (
				begin match read_digits it ~base ~based:(mark <> '\x00') ~will_e:(mark = '\x00') with
				| false, "" ->
					if mark <> '\x00' then (
						add_error it "hexadecimal decimal part expected." (current_position it)
					) else (
						add_error it "decimal part expected." (current_position it)
					);
					true, ""
				| r -> r
				end
			) in
			let error = (
				if mark <> '\x00' then (
					if it.h = mark then (
						take it;
						error
					) else (
						add_error it ("\'" ^ String.make 1 mark ^ "\' expected.") (current_position it);
						true
					)
				) else (
					error
				)
			) in
			begin match it.h with
			| 'E' | 'e' ->
				scan_exponent_part it ~error base integer_part decimal_part true p
			| _ ->
				add_real it ~error base integer_part decimal_part 0 p
			end
		);;
		
		let scan_hexadecimal_part it ~(error: bool) (base: int) (p: text_file_position): unit = (
			assert (it.h = '#' || it.h = ':');
			let mark = it.h in
			take it;
			let error, integer_part = (
				begin match read_digits it ~base:base ~based:true ~will_e:false with
				| false, "" ->
					if it.h = '.' then (
						add_error it "hexadecimal integral part expected." (current_position it)
					) else (
						add_error it "hexadecimal number expected." (current_position it)
					);
					true, ""
				| r -> r
				end
			) in
			if it.h = '.' then (
				take it;
				scan_decimal_part it ~error base integer_part mark p
			) else (
				let error = (
					if it.h = mark then (
						take it;
						error
					) else (
						add_error it ("\'" ^ String.make 1 mark ^ "\' expected.") (current_position it);
						true
					)
				) in
				begin match it.h with
				| 'E' | 'e' ->
					scan_exponent_part it ~error base integer_part "" false p
				| _ ->
					add_integer it ~error base integer_part 0 p
				end
			)
		);;
		
		let attribute_writable it: bool = (
			match it.last with
			| LexicalElement.R Reserved.ALL
			| LexicalElement.R Reserved.NULL
			| LexicalElement.A _
			| LexicalElement.I _
			| LexicalElement.R_paren
			| LexicalElement.Integer_literal _
			| LexicalElement.Real_literal _ 
			| LexicalElement.Character_literal _
			| LexicalElement.Character_code _
			| LexicalElement.String_literal _
			| LexicalElement.Invalid_literal -> true
			| _ -> false
		);;
		
		let rec scan it: unit = (
			skip_spaces it;
			begin match it.h with
			| '(' ->
				add it LexicalElement.L_paren (current_position it);
				take it
			| ')' ->
				add it LexicalElement.R_paren (current_position it);
				take it
			| ';' ->
				add it LexicalElement.Semicolon (current_position it);
				take it
			| ',' ->
				add it LexicalElement.Comma (current_position it);
				take it
			| '|' | '!' -> (* '!' is an alternative style *)
				add it LexicalElement.Vertical (current_position it);
				take it
			| '&' -> 
				add it LexicalElement.Ampersand (current_position it);
				take it
			| '+' -> 
				add it LexicalElement.Plus (current_position it);
				take it
			| '-' -> 
				let p = current_position it in
				take it;
				begin match it.h with
				| '-' ->
					while (
						take it;
						match it.h with
						| '\n' | '\r' | '\x0c' | '\x1a' -> false
						| _ -> true
					) do
						()
					done;
					scan it
				| _ ->
					add it LexicalElement.Minus p
				end
			| '*' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '*' ->
					take it;
					add it LexicalElement.Exponentiate p
				| _ ->
					add it LexicalElement.Asterisk p
				end
			| '/' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '=' ->
					take it;
					add it LexicalElement.NE p
				| _ ->
					add it LexicalElement.Slash p
				end
			| '<' -> 
				let p = current_position it in
				take it;
				begin match it.h with
				| '>' ->
					take it;
					add it LexicalElement.Box p
				| '<' ->
					take it;
					add it LexicalElement.L_label p
				| '=' ->
					take it;
					add it LexicalElement.LE p
				| _ ->
					add it LexicalElement.LT p
				end
			| '>' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '>' ->
					take it;
					add it LexicalElement.R_label p
				| '=' ->
					take it;
					add it LexicalElement.GE p
				| _ ->
					add it LexicalElement.GT p
				end
			| '=' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '>' ->
					take it;
					add it LexicalElement.Arrow p
				| _ ->
					add it LexicalElement.EQ p
				end
			| ':' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '=' ->
					take it;
					add it LexicalElement.Assign p
				| _ ->
					add it LexicalElement.Colon p
				end
			| '.' ->
				let p = current_position it in
				take it;
				begin match it.h with
				| '.' ->
					take it;
					add it LexicalElement.D_dot p
				| '0'..'9' -> (* integer-part-missing error *)
					add_error it "integral part expected." p;
					scan_decimal_part it ~error:true 16 "" '\x00' p
				| _ ->
					add it LexicalElement.Period p
				end
			| 'A'..'Z' | 'a'..'z' | '_' ->
				let p = current_position it in
				let b = Buffer.create 16 in
				Buffer.add_char b it.h;
				while (take it; match it.h with 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true | _ -> false) do
					Buffer.add_char b it.h
				done;
				let ms = Buffer.contents b in
				let us = Identifier.uppercase ms in
				if is_rw us then (
					let rw = rw_of_string us in
					if rw = Reserved.PRAGMA then (
						skip_spaces it;
						begin match it.h with
						| 'A'..'Z' | 'a'..'z' | '_' ->
							let b = Buffer.create 16 in
							Buffer.add_char b it.h;
							while (take it; match it.h with 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true | _ -> false) do
								Buffer.add_char b it.h
							done;
							let mp = Buffer.contents b in
							let up = Identifier.uppercase mp in
							if is_pragma up then (
								let pragma = pragma_of_string up in
								add it (LexicalElement.P pragma) p
							) else (
								add it (LexicalElement.P (Pragma.Unknown mp)) p
							)
						| _ -> 
							add it (LexicalElement.R Reserved.PRAGMA) p
						end
					) else (
						add it (LexicalElement.R rw) p
					)
				) else (
					add it (LexicalElement.I (us, ms)) p
					(* underscore check be lazy *)
				)
			| '\'' -> 
				let quote_position = current_position it in
				take it;
				let letter_position = current_position it in
				let c_len = UTF8.sequence it.h in
				let c = it.h in
				take it;
				if c_len = 1 && (it.h <> '\'' || attribute_writable it) then (
					let d, next_position = (
						match c with
						| 'A'..'Z' | 'a'..'z' | '_' | '(' -> c, letter_position
						| ' ' | '\n' | '\r' | '\t' | '\x0b' | '\x0c' -> 
							skip_spaces it;
							begin match it.h with
							| 'A'..'Z' | 'a'..'z' | '_' | '(' -> 
								let c = it.h in
								let letter_position = current_position it in
								take it; 
								c, letter_position
							| _ -> '\x00', letter_position
							end
						| _ -> '\x00', letter_position
					) in
					if d = '(' then (
						add it LexicalElement.Quote quote_position;
						add it LexicalElement.L_paren next_position
					) else if d <> '\x00' then (
						let b = Buffer.create 16 in
						Buffer.add_char b d;
						while (match it.h with 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true | _ -> false) do
							Buffer.add_char b it.h;
							take it
						done;
						let a = Buffer.contents b in
						let ua = Identifier.uppercase a in
						if is_attr ua then (
							let attr = attr_of_string ua in
							add it (LexicalElement.A attr) quote_position
						) else (
							add it (LexicalElement.A (Attribute.Unknown a)) quote_position
						)
					) else if it.h = '\'' then (
						take it;
						add it (LexicalElement.Character_literal (String.make 1 c)) quote_position;
						add_error it "character literal shoud have single character." quote_position
					) else (
						add it (LexicalElement.Character_literal (String.make 1 c)) quote_position;
						add_error it "'\'' expected." (current_position it)
					)
				) else (
					let s = String.make c_len '\x00' in
					s.[0] <- c;
					let i = ref 1 in
					while !i < c_len && (Char.code it.h >= 0b10000000 && Char.code it.h < 0b10111111) do
						s.[!i] <- it.h;
						take it;
						incr i
					done;
					if it.h <> '\'' then (
						add_error it "'\'' expected." (current_position it);
						add it LexicalElement.Invalid_literal quote_position
					) else (
						take it;
						if !i < c_len then (
							add_error it "invalid UTF-8 sequence." letter_position;
							add it LexicalElement.Invalid_literal quote_position
						) else (
							let code = UTF8.get_code s (ref 0) in
							if code < 32 then (
								add_error it "control code in character literal." letter_position;
								add it LexicalElement.Invalid_literal quote_position
							) else (
								add it (LexicalElement.Character_literal s) quote_position
							)
						)
					)
				)
			| '\"' | '%' -> 
				let quote_position = current_position it in
				let quote = it.h in
				let b = Buffer.create 16 in
				while (
					take it;
					begin match it.h with
					| '\r' | '\n' | '\x0c' | '\x1a' ->
						add it (LexicalElement.String_literal (Buffer.contents b)) quote_position;
						add_error it "'\"' expected." (current_position it);
						false
					| _ when it.h = quote ->
						take it; 
						if it.h = quote then (
							Buffer.add_char b quote;
							true
						) else (
							add it (LexicalElement.String_literal (Buffer.contents b)) quote_position;
							false
						)
					| _ ->
						if Char.code it.h < 32 then (
							add_error it "control code in string literal." (current_position it)
						) else if it.h = '\"' then (
							add_error it "string literal quoted with \'%\' can not contain \'\"\'." (current_position it)
						);
						Buffer.add_char b it.h;
						true
					end
				) do
					()
				done
			| '0'..'9' ->
				let p = current_position it in
				let error, integer_part = read_digits it ~base:10 ~based:false ~will_e:true in
				begin match it.h with
				| '#' | ':' ->
					let error, base = (
						let b = int_of_string integer_part in
						if b >= 2 && b <= 16 then (
							error, b
						) else (
							add_error it "base should be in 2..16." p;
							true, 16
						)
					) in
					scan_hexadecimal_part it ~error base p
				| '.' ->
					let dot_p = current_position it in
					take it;
					if it.h = '.' then (
						take it;
						add_integer it ~error 10 integer_part 0 p;
						add it LexicalElement.D_dot dot_p
					) else (
						scan_decimal_part it ~error 10 integer_part '\x00' p
					)
				| 'e' | 'E' ->
					scan_exponent_part it ~error 10 integer_part "" false p
				| _ ->
					add_integer it ~error 10 integer_part 0 p
				end
			| '#' -> (* base-missing error *)
				let p = current_position it in
				add_error it "base expected." p;
				scan_hexadecimal_part it ~error:true 16 p
			| '[' ->
				let p = current_position it in
				take it;
				let quoted = it.h = '\"' in
				if quoted then take it;
				let error, s = read_digits it ~base:16 ~based:false ~will_e:false in
				let error = (
					if quoted then (
						if it.h = '\"' then (
							take it;
							error
						) else (
							add_error it "'\"' expected." (current_position it);
							true
						)
					) else (
						error
					)
				) in
				let error = (
					if it.h = ']' then (
						take it;
						error
					) else (
						add_error it "']' expected." (current_position it);
						true
					)
				) in
				begin try
					let len = String.length s in
					if error || (len <> 2 && len <> 4 && len <> 8) then raise (Failure "");
					let code = Int32.of_string ("0x" ^ s) in
					add it (LexicalElement.Character_code (len * 4, code)) p
				with Failure _ ->
					add_error it "Invalid character code." p;
					add it LexicalElement.Invalid_literal p
				end
			| '\x1a' ->
				add it LexicalElement.Eof (current_position it)
			| _ ->
				add_error it ("\'" ^ String.make 1 it.h ^ "\' is bad character.") (current_position it);
				take it
			end
		);;
		
	end;;
	open Private;;
	
	let next (it: t): LexicalElement.t * text_file_position = (
		if Queue.is_empty it.tokens then (
			scan it
		);
		Queue.take it.tokens
	);;
	
end;;
